home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / big.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  7.9 KB  |  466 lines
  1.   /* Copyright William F. Schelter 1991
  2.    Bignum routines.
  3.  
  4.  
  5.    
  6. num_arith.c: add_int_big
  7. num_arith.c: big_minus
  8. num_arith.c: big_plus
  9. num_arith.c: big_quotient_remainder
  10. num_arith.c: big_sign
  11. num_arith.c: big_times
  12. num_arith.c: complement_big
  13. num_arith.c: copy_big
  14. num_arith.c: div_int_big
  15. num_arith.c: mul_int_big
  16. num_arith.c: normalize_big
  17. num_arith.c: normalize_big_to_object
  18. num_arith.c: stretch_big
  19. num_arith.c: sub_int_big
  20. num_comp.c: big_compare
  21. num_comp.c: big_sign
  22. num_log.c: big_sign
  23. num_log.c: copy_to_big
  24. num_log.c: normalize_big
  25. num_log.c: normalize_big_to_object
  26. num_log.c: stretch_big
  27. num_pred.c: big_sign
  28. number.c: big_to_double
  29. predicate.c: big_compare
  30. typespec.c: big_sign
  31. print.d: big_minus
  32. print.d: big_sign
  33. print.d: big_zerop
  34. print.d: copy_big
  35. print.d: div_int_big
  36. read.d: add_int_big
  37. read.d: big_to_double
  38. read.d: complement_big
  39. read.d: mul_int_big
  40. read.d: normalize_big
  41. read.d: normalize_big_to_object
  42.  
  43.  */
  44.  
  45.  
  46.  
  47. #define remainder gclremainder
  48. #include "include.h"
  49. #include "mp.h"
  50.  
  51.  
  52.  
  53.  
  54. #define BCOPY_BODY(x,y) \
  55. do { int *ucop = (int *)(x); \
  56.     int *vcop = (int *) (y); \
  57.   {int j = lgef(ucop); \
  58.     while(--j >= 0) \
  59.       { *vcop++ = *ucop++;}}}while (0)
  60.  
  61. bcopy_body(x,y)
  62.     GEN x,y;
  63. {BCOPY_BODY(x,y);}
  64.  
  65.  
  66.  
  67.  
  68. /* coerce a pari GEN to a bignum or fixnum */
  69.  
  70. object
  71. make_integer(u)
  72. GEN u;
  73. { int l = lgef(u);
  74.   if (l > (MP_CODE_WORDS+1) ||
  75.       ( l == (MP_CODE_WORDS+1)  &&
  76.        (MP_ONLY_WORD(u) & (1<<31)) != 0
  77.        && (MP_ONLY_WORD(u) == ( 1<<31) ? signe(u) > 0 : 1)))
  78.     { object ans ;
  79.       GEN w;
  80.       big_register_1->big.big_length = lg(u);
  81.       big_register_1->big.big_self = u;
  82.       ans = alloc_object(t_bignum);
  83.       ans->big.big_self = 0;
  84.       w = (GEN)alloc_relblock(l*sizeof(int));
  85.       /* may have been relocated */
  86.       u =   big_register_1->big.big_self ;
  87.       ans->big.big_self = w;
  88.       ans->big.big_length = l;
  89.       BCOPY_BODY(u , w);
  90.       setlg(w,l);
  91.       return ans;
  92.     }
  93.   else
  94.     if (signe(u) > 0) return make_fixnum(MP_ONLY_WORD(u));
  95.   else
  96.     if (signe(u) < 0) return make_fixnum(-MP_ONLY_WORD(u));
  97.   else
  98.     return(small_fixnum(0));
  99.  }
  100.  
  101.  
  102. object
  103. make_bignum(u)
  104. GEN u;
  105.     { object ans = alloc_object(t_bignum);
  106.       GEN w;
  107.       ans->big.big_length = lg(u);
  108.       /* save u */
  109.       ans->big.big_self = u;
  110.       w = (GEN)alloc_relblock(lg(u)*sizeof(int));
  111.       /* restore  u */
  112.       u = ans->big.big_self ;
  113.       ans->big.big_self = w;
  114.       BCOPY_BODY(u ,  ans->big.big_self);
  115.       return ans;
  116.      }
  117.  
  118. big_zerop(x)
  119.  object x;
  120. { return (signe(MP(x))== 0);}
  121.  
  122. big_compare(x, y)
  123.      object x,y;
  124. {return cmpii(MP(x),MP(y));}
  125.  
  126. object
  127. big_minus(x)
  128.      object x;
  129. { object y; 
  130.   setsigne(MP(x),-(signe(MP(x))));
  131.   y = make_integer(MP(x));
  132.   setsigne(MP(x),-(signe(MP(x))));
  133.   return  y;
  134. }
  135.  
  136. gcopy_to_big(res,x)
  137.      GEN res;
  138.      object x;
  139. {int l = (x)->big.big_length;
  140.  int lgres = lg(res);
  141.  if (l< lgres)
  142.     { 
  143.       big_register_1->big.big_length = lgres;
  144.       big_register_1->big.big_self = res;
  145.       (x)->big.big_self = (GEN) alloc_relblock(lgres*sizeof(int));
  146.       (x)->big.big_length = lgres; 
  147.       res =    big_register_1->big.big_self ;
  148.      }
  149.  BCOPY_BODY(res,(x)->big.big_self);
  150.   if (l>lgres)
  151.     { setlg((x)->big.big_self, l);}
  152. } 
  153.         
  154.  
  155. add_int_big(i, x)
  156. int i;
  157. object x;
  158. {
  159.        MPOP_DEST(x,addsi,i,MP(x));
  160. }
  161.  
  162.  
  163. sub_int_big(i, x)
  164. int i;
  165. object x;
  166. { MPOP_DEST(x,subsi,i,MP(x));
  167. }
  168.  
  169. mul_int_big(i, x)
  170. int i;
  171. object x;
  172. { MPOP_DEST(x,mulsi,i,MP(x));
  173. }    
  174.  
  175. /*
  176.     Div_int_big(i, x) destructively divides non-negative bignum x
  177.     by positive int i.
  178.     X will hold the quotient from  the division.
  179.     Div_int_big(i, x) returns the remainder of the division.
  180.     I should be positive.
  181.     X should be non-negative.
  182. */
  183.  
  184. div_int_big(i, x)
  185. int i;
  186. object x;
  187. { save_avma;
  188.   GEN res = divis(MP(x),i);
  189.   gcopy_to_big(res,x);
  190.   restore_avma;
  191.   return hiremainder;
  192. }
  193.  
  194.  
  195. object
  196. big_plus(x, y)
  197. object x,y;
  198. { MPOP(return,addii,MP(x),MP(y));
  199. }
  200.  
  201. object
  202. big_times(x, y)
  203. object x,y;
  204. { MPOP(return,mulii,MP(x),MP(y));
  205. }
  206.  
  207.  
  208.  
  209. big_quotient_remainder(x0, y0, qp, rp)
  210.      object x0,y0,*qp,*rp;
  211. {
  212.   GEN res,quot;
  213.   save_avma;
  214.   res = dvmdii(MP(x0),MP(y0),");
  215.   *qp = make_integer(res);
  216.   *rp = make_integer(quot);
  217.   restore_avma;
  218.   return;
  219.  
  220. }
  221.  
  222.     
  223. double
  224. big_to_double(x)
  225.      object x;
  226. {
  227.     double d, e;
  228.     GEN u = MP(x);
  229.     unsigned int *w;
  230.     int l;
  231.     e =  4.294967296e9;
  232.  
  233.     l = lgef(u);
  234.     MP_START_HIGH(w,(unsigned int *) u,l);
  235.     l = l - MP_CODE_WORDS;
  236.  
  237.     if (l == 0) return 0.0;
  238.  
  239.     d = (double) MP_NEXT_DOWN(w);
  240.     while (--l > 0)
  241.       {d = e*d + (double)(MP_NEXT_DOWN(w));}
  242.     if (signe(u)>0) return d;
  243.       else return -d;
  244.       }
  245.     
  246.  
  247. object
  248. normalize_big_to_object(x)
  249.  object x;
  250. { return make_integer(MP(x));}
  251.   
  252.  
  253. object copy_big(x)
  254.      object x;
  255. {
  256.   if (type_of(x)==t_bignum)
  257.     return make_bignum(MP(x));
  258.   else FEerror("bignum expected",0);
  259.  
  260. }
  261.  
  262.  
  263. object
  264. copy_to_big(x)
  265.      object x;
  266. {object y;
  267.  
  268.     if (type_of(x) == t_fixnum) {
  269.       save_avma;
  270.       y = make_bignum(stoi(fix(x)));
  271.       restore_avma;
  272.     } else if (type_of(x) == t_bignum)
  273.         y = copy_big(x);
  274.     else
  275.         FEerror("integer expected",0);
  276.     return(y);
  277.       }
  278.   
  279.  
  280. /* return the power of x */
  281. GEN
  282. powerii(x,y)
  283.      GEN x, y;
  284. {  GEN ans = gun;
  285.    if (signe(y) < 0) FEerror("bad");
  286.    while (lgef(y) > 2){
  287.      if (MP_LOW(y,lgef(y)) & 1)
  288.        { ans = mulii(ans,x);}
  289.      x = mulii(x,x);
  290.      y = shifti(y,-1);}
  291.    return ans;
  292.  }
  293.  
  294. object integ_temp;
  295.  
  296.  
  297. replace_copy1(x,y)
  298.      GEN y,x;
  299. { int j = lgef(x);
  300.  if (y && j <= lg(y))
  301.     { x++; y++;
  302.       while (--j >0)
  303.       {*y++ = *x++;}
  304.      return 0;}
  305.  END:
  306.  return j*2*sizeof(GEN);
  307. }
  308.  
  309. /* doubles the length ! */
  310. GEN
  311. replace_copy2(x,y)
  312.      GEN y,x;
  313. {GEN yp = y;  
  314.  int k,j = lgef(x);
  315.  k = j;
  316.  while (--j >=0)
  317.    {*yp++ = *x++;}
  318.  y[0] = INT_FLAG + k*2;
  319.  return y;}
  320.  
  321. #define STOI(x,y) do{ \
  322.   if (x ==0) { y[1]=2;} \
  323.   else if((x)>0) {y[1]=0x1000003;y[2]=x;} \
  324.                   else{y[1]=0xff000003;y[2]= -x;}}while (0)
  325.  
  326. /* actually y == 0 is not supposed to happen !*/
  327.             
  328. obj_replace_copy1(x,y)
  329.      object x;
  330.      GEN y;
  331. { int j ;
  332.   GEN xp;
  333.   { if (type_of(x) == t_bignum)
  334.       {   j = lgef(MP(x));
  335.       if (y && j <= lg(y))
  336.         { xp=MP(x);
  337.           xp++; y++;
  338.           while (--j >0)
  339.         {*y++ = *xp++;}
  340.           return 0;}}
  341.   else
  342.     { if (y==0) return 3*2*sizeof(GEN) ;
  343.       STOI(fix(x),y); return 0;}}
  344.  END:
  345.  return j*2*sizeof(GEN);
  346. }
  347.  
  348. /* doubles the length ! */
  349. GEN
  350. obj_replace_copy2(x,y)
  351.      object x;
  352.      GEN y;
  353. {GEN yp = y;
  354.  GEN xp;
  355.  int k,j;
  356.  if (type_of(x) == t_bignum)
  357.    { j = lgef(MP(x));
  358.      k = j;
  359.      xp = MP(x);
  360.      while (--j >=0)
  361.        {*yp++ = *xp++;}
  362.      y[0] = INT_FLAG + k*2;}
  363.  else  {STOI(fix(x),yp); y[0] = INT_FLAG+3*2;}
  364.  return y;}
  365.  
  366.  
  367. GEN
  368. otoi(x)
  369.      object x;
  370. {if (type_of(x)==t_fixnum) return stoi(fix(x));
  371.  if (type_of(x)==t_bignum)
  372.    return (MP(x));
  373.  FEwrong_type_argument(Sinteger,x);
  374.  return 0;
  375. }
  376.  
  377. object
  378. alloc_bignum_static(len)
  379. int len;
  380.     { object ans = alloc_object(t_bignum);
  381.       GEN w;
  382.       ans->big.big_length = len;
  383.       ans->big.big_self = 0;
  384.       w = (GEN)AR_ALLOC(alloc_contblock,len,unsigned long);
  385.       ans->big.big_self = w;
  386.       w[0] = INT_FLAG + len;
  387.       return ans;
  388.      }
  389.  
  390.  
  391. GEN
  392. setq_io(x,all,val)
  393.      GEN x;
  394.      object val;
  395.      object *all;
  396. {int n= obj_replace_copy1(val,x);
  397.  if (n)
  398.    { *all = alloc_bignum_static(n/sizeof(int));
  399.      return obj_replace_copy2(val,MP(*all));
  400.    }
  401.  else return x;}
  402.  
  403.  
  404. GEN
  405. setq_ii(x,all,val)
  406.      GEN x;
  407.      GEN val;
  408.      object *all;
  409. {int n= replace_copy1(val,x);
  410.  if (n)
  411.    { *all = alloc_bignum_static(n/sizeof(int));
  412.      return replace_copy2(val,MP(*all));
  413.    }
  414.  else return x;}
  415.  
  416.  
  417.  
  418.  
  419. void
  420. isetq_fix(var,s)
  421.      GEN var;
  422.      int s;
  423. {/* if (var==0) FEerror("unitialized integer var"); */
  424.  STOI(s,var);
  425. }
  426.  
  427. GEN
  428. icopy_bignum(a,y)
  429.      object a;
  430.      GEN y;
  431. { int *ucop = (int *)MP(a); 
  432.   int *vcop = (int *) (y);
  433.   int j = lgef(ucop);
  434.   {while(--j >= 0) 
  435.      { *vcop++ = *ucop++;}
  436.    setlg(y,a->big.big_length);
  437.    return y;}}
  438.      
  439.  
  440. GEN
  441. icopy_fixnum(a,y)
  442.      object a;
  443.      GEN y;
  444.        
  445. { int x= fix(a);
  446.   if(!x) return gzero;
  447.   y[0]=INT_FLAG+3;
  448.   if(x>0) {y[1]=0x1000003;y[2]=x;}
  449.   else{y[1]=0xff000003;y[2]= -x;}
  450.   return y;
  451. }
  452.      
  453.  
  454.  
  455.      
  456.  
  457.  
  458.   
  459.  
  460.  
  461.  
  462.  
  463.  
  464.  
  465.  
  466.